TTE Modeling Results

Results path: results/2024-11-04-16-04-42.547127

Author

Lukas A. Widmer, Sebastian Weber, Yunnan Xu, Hans-Jochen Weber

Trial speed

Code
p = list()

for( cur_scenario in unique(outcome_fig_noninformative$scenario)){
  cur_plot <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) |>
    ggplot(
      aes(x = dropout, y=last_cohort_time, fill = model)
    ) + 
    # geom_boxplot( alpha = 0.5) + 
    stat_histinterval(
      position = position_dodgejust(width = 0.8), 
      width = 0.8, 
      breaks = 1:max(outcome_fig_noninformative$last_cohort_time)
    ) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p) == 0, "# Cohorts", "")) + ylim(c(1,max(outcome_fig_noninformative$last_cohort_time))) +
    labs(fill='Method:') +
    xlab("Dropout over 3 cycles")
  
  p <- c(p, list(cur_plot))
}
plot_ncohorts <- ggarrange(plotlist = p, common.legend = T, ncol = 3) 
plot_ncohorts_ann <- annotate_figure(plot_ncohorts, top = text_grob("Number of cohorts enrolled in trial", 
                                          color = "black", face = "bold", size = 14))


plot_ncohorts_ann

Enrolled patients

Code
p = list()

for( cur_scenario in unique(outcome_fig_noninformative$scenario)){
  
  cur_data <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) 
  
  cur_plot <- cur_data |>
    ggplot(
      aes(x = dropout, y=num_patients_start, fill = model)
    ) + 
    # geom_boxplot( alpha = 0.5) + 
    stat_histinterval(
      position = position_dodgejust(width = 0.8), 
      width = 0.8, 
      breaks = 3*(1:max(outcome_fig_noninformative$last_cohort_time))
    ) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p) == 0, "# Patients", "")) + ylim(c(1,max(outcome_fig_noninformative$num_patients_start))) +
    labs(fill='Method:') + 
    xlab("Dropout over 3 cycles")
  
  cur_data_summary <- cur_data |> 
    group_by(dropout, model) |> 
    summarize(num_patients_start = rvar(num_patients_start), .groups = "keep") |>
    mutate(
      num_patients_start_mean = mean(num_patients_start),
      num_patients_start_mean_mcse = mcse_mean(num_patients_start)
    )
  
  cat(paste0("\n### ", cur_scenario, "\n\n"))

  if (interactive()) {
    print(cur_data_summary |> kable())
  } else {
    cat(sep = "\n", knitr::knit_child(quiet = TRUE, text = c(
      "```{r}",
      "#| echo: false",
      "cur_data_summary |> kable(digits = 1)",
      "```"
    )))
  }
  
  p <- c(p, list(cur_plot))
}

constant

dropout model num_patients_start num_patients_start_mean num_patients_start_mean_mcse
0% B1 23 ± 3.1 23.1 0.1
0% B3 16 ± 5.0 15.5 0.2
0% TCO 22 ± 3.5 21.9 0.1
0% TCU 16 ± 4.5 16.2 0.2
33% B1 26 ± 3.6 26.3 0.1
33% B3 20 ± 7.5 20.4 0.2
33% TCO 24 ± 4.2 24.4 0.1
33% TCU 18 ± 5.4 18.1 0.2
55% B1 29 ± 4.2 28.5 0.1
55% B3 25 ± 10.7 24.9 0.3
55% TCO 26 ± 4.5 26.0 0.1
55% TCU 20 ± 6.0 19.6 0.2

increasing

dropout model num_patients_start num_patients_start_mean num_patients_start_mean_mcse
0% B1 25 ± 2.8 24.8 0.1
0% B3 15 ± 5.0 15.1 0.2
0% TCO 22 ± 3.8 22.3 0.1
0% TCU 16 ± 4.8 15.9 0.2
33% B1 27 ± 3.7 27.4 0.1
33% B3 21 ± 7.7 20.6 0.2
33% TCO 25 ± 4.6 24.7 0.2
33% TCU 18 ± 5.6 17.9 0.2
55% B1 30 ± 4.5 30.4 0.1
55% B3 26 ± 10.9 26.2 0.3
55% TCO 27 ± 5.0 26.7 0.2
55% TCU 20 ± 6.3 19.9 0.2

decreasing

dropout model num_patients_start num_patients_start_mean num_patients_start_mean_mcse
0% B1 22 ± 2.7 21.9 0.1
0% B3 15 ± 5.0 15.4 0.2
0% TCO 22 ± 3.3 21.8 0.1
0% TCU 16 ± 4.6 16.0 0.2
33% B1 25 ± 3.5 25.1 0.1
33% B3 19 ± 7.7 19.5 0.2
33% TCO 24 ± 4.2 24.1 0.1
33% TCU 18 ± 5.5 18.1 0.2
55% B1 27 ± 4.1 27.1 0.1
55% B3 23 ± 10.7 22.9 0.4
55% TCO 26 ± 4.3 25.7 0.1
55% TCU 20 ± 5.9 19.7 0.2
Code
plot_npatients <- ggarrange(plotlist = p, common.legend = T, ncol = 3) 
plot_npatients_ann <- annotate_figure(plot_npatients, top = text_grob("Number of patients enrolled in trial", 
                                                                  color = "black", face = "bold", size = 14))


ggsave(file.path(path.export, "npatients.pdf"), plot = plot_npatients_ann , width=20*2.5, height=10*1.2, units="cm")

Plot

Code
plot_npatients_ann

Stopping reasons & MTD allocation, Cycle 1

Code
preprocess_data_MTD_cycle1 <- function(x, cur_scenario) {
  cur_data <- x |>
    filter(scenario == cur_scenario)
  
  cur_data |> 
    count(model, dropout, stop_reason_cycle1) |>    
    group_by(model, dropout) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

p_cycle1_MTDs = list()
for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- preprocess_data_MTD_cycle1(outcome_fig_noninformative, cur_scenario) |>
    ggplot(aes(x = dropout, y = n, fill = stop_reason_cycle1)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cycle1_MTDs) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values = dosing_colors, drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Stopping reason') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) + 
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cycle1_MTDs <- c(p_cycle1_MTDs, list(cur_plot))
}
plot_cycle1_MTDs <- ggarrange( plotlist = p_cycle1_MTDs, common.legend = T, ncol = 3)
plot_cycle1_MTDs_ann <- plot_cycle1_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cycle-1 MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_cycle1_MTDs_ann

Code
ggsave(file.path(path.export, "MTD_cycle1_frequencies.pdf"), plot = plot_cycle1_MTDs_ann , width=20*2.5, height=10*1.2, units="cm")

Stopping reasons & MTD allocation, Cumulative

Code
preprocess_data_MTD_cumulative <- function(x, cur_scenario) {
  cur_data <- x |>
    filter(scenario == cur_scenario)
  
  cur_data |> 
    count(model, dropout, stop_reason_cumulative) |>    
    group_by(model, dropout) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

p_cumulative_MTDs = list()

n_sims <- unique((outcome_fig_noninformative |>
    count(model, dropout, scenario))$n)

for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- preprocess_data_MTD_cumulative(outcome_fig_noninformative, cur_scenario) |>
    ggplot(aes(x = dropout, y = n, fill = stop_reason_cumulative)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cumulative_MTDs) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values = dosing_colors, drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Stopping reason') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) + 
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cumulative_MTDs <- c(p_cumulative_MTDs, list(cur_plot))
  
  cur_data_summary <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) |>
    group_by(dropout, model) |>
    summarize(
      rvar_MTD_target = rvar(MTD_is_target_cumulative * 1.0), 
      rvar_MTD_overdose = rvar(MTD_is_overdose_cumulative * 1.0), 
      rvar_MTD_underdose = rvar(MTD_is_underdose_cumulative * 1.0), 
      rvar_stopped = rvar(stopped_due_to_toxicity * 1.0),
      .groups = "keep"
    ) |>
    mutate(
      mean_MTD_target = mean(rvar_MTD_target),
      mcse_MTD_target = mcse_mean(rvar_MTD_target),
      mean_MTD_overdose = mean(rvar_MTD_overdose),
      mcse_MTD_overdose = mcse_mean(rvar_MTD_overdose),
      mean_MTD_underdose = mean(rvar_MTD_underdose),
      mcse_MTD_underdose = mcse_mean(rvar_MTD_underdose),
      mean_stopped = mean(rvar_stopped),
      mcse_stopped = mcse_mean(rvar_stopped)
    )
  

  cat(paste0("\n### ", cur_scenario, "\n\n"))

  if (interactive()) {
    print(cur_data_summary |> kable())
  } else {
    cat(sep = "\n", knitr::knit_child(quiet = TRUE, text = c(
      "```{r}",
      "#| echo: false",
      "cur_data_summary |> kable(digits = 2)",
      "```"
    )))
  }
}

constant

dropout model rvar_MTD_target rvar_MTD_overdose rvar_MTD_underdose rvar_stopped mean_MTD_target mcse_MTD_target mean_MTD_overdose mcse_MTD_overdose mean_MTD_underdose mcse_MTD_underdose mean_stopped mcse_stopped
0% B1 0.20 ± 0.40 0.799 ± 0.401 0.000 ± 0.000 0.000 ± 0.000 0.20 0.01 0.80 0.01 0.00 NA 0.00 NA
0% B3 0.87 ± 0.33 0.001 ± 0.032 0.006 ± 0.077 0.119 ± 0.324 0.87 0.01 0.00 0.00 0.01 0 0.12 0.01
0% TCO 0.11 ± 0.32 0.883 ± 0.322 0.000 ± 0.000 0.003 ± 0.055 0.11 0.01 0.88 0.01 0.00 NA 0.00 0.00
0% TCU 0.89 ± 0.31 0.012 ± 0.109 0.000 ± 0.000 0.096 ± 0.295 0.89 0.01 0.01 0.00 0.00 NA 0.10 0.01
33% B1 0.26 ± 0.44 0.741 ± 0.438 0.000 ± 0.000 0.000 ± 0.000 0.26 0.01 0.74 0.01 0.00 NA 0.00 NA
33% B3 0.83 ± 0.37 0.001 ± 0.032 0.000 ± 0.000 0.168 ± 0.374 0.83 0.01 0.00 0.00 0.00 NA 0.17 0.01
33% TCO 0.13 ± 0.33 0.868 ± 0.339 0.000 ± 0.000 0.004 ± 0.063 0.13 0.01 0.87 0.01 0.00 NA 0.00 0.00
33% TCU 0.89 ± 0.31 0.006 ± 0.077 0.001 ± 0.032 0.100 ± 0.300 0.89 0.01 0.01 0.00 0.00 0 0.10 0.01
55% B1 0.31 ± 0.46 0.688 ± 0.464 0.000 ± 0.000 0.000 ± 0.000 0.31 0.01 0.69 0.01 0.00 NA 0.00 NA
55% B3 0.72 ± 0.45 0.000 ± 0.000 0.000 ± 0.000 0.279 ± 0.449 0.72 0.01 0.00 NA 0.00 NA 0.28 0.01
55% TCO 0.18 ± 0.38 0.821 ± 0.384 0.000 ± 0.000 0.003 ± 0.055 0.18 0.01 0.82 0.01 0.00 NA 0.00 0.00
55% TCU 0.87 ± 0.34 0.006 ± 0.077 0.001 ± 0.032 0.124 ± 0.330 0.87 0.01 0.01 0.00 0.00 0 0.12 0.01

increasing

dropout model rvar_MTD_target rvar_MTD_overdose rvar_MTD_underdose rvar_stopped mean_MTD_target mcse_MTD_target mean_MTD_overdose mcse_MTD_overdose mean_MTD_underdose mcse_MTD_underdose mean_stopped mcse_stopped
0% B1 0.011 ± 0.10 0.989 ± 0.104 0.000 ± 0.000 0.000 ± 0.000 0.01 0.00 0.99 0.00 0 NA 0.00 NA
0% B3 0.871 ± 0.34 0.002 ± 0.045 0.002 ± 0.045 0.125 ± 0.331 0.87 0.01 0.00 0.00 0 0 0.12 0.01
0% TCO 0.036 ± 0.19 0.956 ± 0.205 0.000 ± 0.000 0.008 ± 0.089 0.04 0.01 0.96 0.01 0 NA 0.01 0.00
0% TCU 0.839 ± 0.37 0.015 ± 0.122 0.000 ± 0.000 0.146 ± 0.353 0.84 0.01 0.01 0.00 0 NA 0.15 0.01
33% B1 0.020 ± 0.14 0.980 ± 0.140 0.000 ± 0.000 0.000 ± 0.000 0.02 0.00 0.98 0.00 0 NA 0.00 NA
33% B3 0.836 ± 0.37 0.002 ± 0.045 0.000 ± 0.000 0.162 ± 0.369 0.84 0.01 0.00 0.00 0 NA 0.16 0.01
33% TCO 0.042 ± 0.20 0.941 ± 0.236 0.000 ± 0.000 0.017 ± 0.129 0.04 0.01 0.94 0.01 0 NA 0.02 0.00
33% TCU 0.832 ± 0.37 0.014 ± 0.118 0.000 ± 0.000 0.154 ± 0.361 0.83 0.01 0.01 0.00 0 NA 0.15 0.01
55% B1 0.031 ± 0.17 0.969 ± 0.173 0.000 ± 0.000 0.000 ± 0.000 0.03 0.01 0.97 0.01 0 NA 0.00 NA
55% B3 0.785 ± 0.41 0.000 ± 0.000 0.000 ± 0.000 0.215 ± 0.411 0.78 0.01 0.00 NA 0 NA 0.22 0.01
55% TCO 0.037 ± 0.19 0.941 ± 0.236 0.000 ± 0.000 0.022 ± 0.147 0.04 0.01 0.94 0.01 0 NA 0.02 0.00
55% TCU 0.825 ± 0.38 0.012 ± 0.109 0.000 ± 0.000 0.163 ± 0.370 0.82 0.01 0.01 0.00 0 NA 0.16 0.01

decreasing

dropout model rvar_MTD_target rvar_MTD_overdose rvar_MTD_underdose rvar_stopped mean_MTD_target mcse_MTD_target mean_MTD_overdose mcse_MTD_overdose mean_MTD_underdose mcse_MTD_underdose mean_stopped mcse_stopped
0% B1 0.50 ± 0.50 0.500 ± 0.500 0.000 ± 0.000 0.000 ± 0.00 0.50 0.02 0.50 0.02 0.00 NA 0.00 NA
0% B3 0.87 ± 0.34 0.006 ± 0.077 0.007 ± 0.083 0.119 ± 0.32 0.87 0.01 0.01 0.00 0.01 0 0.12 0.01
0% TCO 0.21 ± 0.41 0.790 ± 0.408 0.000 ± 0.000 0.000 ± 0.00 0.21 0.01 0.79 0.01 0.00 NA 0.00 NA
0% TCU 0.92 ± 0.27 0.008 ± 0.089 0.000 ± 0.000 0.074 ± 0.26 0.92 0.01 0.01 0.00 0.00 NA 0.07 0.01
33% B1 0.55 ± 0.50 0.446 ± 0.497 0.000 ± 0.000 0.000 ± 0.00 0.55 0.02 0.45 0.02 0.00 NA 0.00 NA
33% B3 0.79 ± 0.41 0.000 ± 0.000 0.002 ± 0.045 0.211 ± 0.41 0.79 0.01 0.00 NA 0.00 0 0.21 0.01
33% TCO 0.25 ± 0.44 0.746 ± 0.436 0.000 ± 0.000 0.000 ± 0.00 0.25 0.01 0.75 0.01 0.00 NA 0.00 NA
33% TCU 0.92 ± 0.27 0.001 ± 0.032 0.002 ± 0.045 0.079 ± 0.27 0.92 0.01 0.00 0.00 0.00 0 0.08 0.01
55% B1 0.61 ± 0.49 0.387 ± 0.487 0.000 ± 0.000 0.000 ± 0.00 0.61 0.01 0.39 0.01 0.00 NA 0.00 NA
55% B3 0.61 ± 0.49 0.000 ± 0.000 0.000 ± 0.000 0.393 ± 0.49 0.61 0.02 0.00 NA 0.00 NA 0.39 0.02
55% TCO 0.31 ± 0.46 0.689 ± 0.463 0.000 ± 0.000 0.000 ± 0.00 0.31 0.01 0.69 0.01 0.00 NA 0.00 NA
55% TCU 0.90 ± 0.30 0.004 ± 0.063 0.000 ± 0.000 0.098 ± 0.30 0.90 0.01 0.00 0.00 0.00 NA 0.10 0.01

Plot

Code
plot_cumulative_MTDs <- ggarrange( plotlist = p_cumulative_MTDs, common.legend = T, ncol = 3)
plot_cumulative_MTDs_ann <- plot_cumulative_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_cumulative_MTDs_ann

Code
ggsave(file.path(path.export, "MTD_cumulative_frequencies.png"), plot = plot_cumulative_MTDs_ann , width=20*2.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "MTD_cumulative_frequencies.pdf"), plot = plot_cumulative_MTDs_ann , width=20*2.5, height=10*1.2, units="cm")

Joint figure

Code
plotlist_both <- c(
    p_cycle1_MTDs |> map(\(x){x + xlab("")}), 
    p_cumulative_MTDs |> map(\(x){x + ggtitle("")})
  )

plotlist_both[[1]] <- plotlist_both[[1]] + ylab("Relative frequencies, cycle-1")
plotlist_both[[4]] <- plotlist_both[[4]] + ylab("Relative frequencies, cumulative")
plot_both_MTDs <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 3, nrow = 2
)
plot_both_MTDs_ann <- plot_both_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cycle-1 and cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  )


ggsave(file.path(path.export, "MTD_frequencies.pdf"), plot = plot_both_MTDs_ann , width=20*2.5, height=10*2, units="cm")
ggsave(file.path(path.export, "MTD_frequencies.png"), plot = plot_both_MTDs_ann , width=20*2.5, height=10*2, units="cm")


plot_both_MTDs_ann

Patient allocation, Cycle 1

Code
p_cycle1_patients = list()
for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  res <- outcome_fig_noninformative |>
    select(
      scenario, model, dropout, 
      num_patients_cycle1, 
      num_patients_overdose_cycle1,
      num_patients_target_cycle1,
      num_patients_underdose_cycle1
    ) |> 
    group_by(scenario, model, dropout) |>
    summarize(
      prob_patients_overdose_cycle1  = sum(num_patients_overdose_cycle1)  / sum(num_patients_cycle1),
      prob_patients_target_cycle1    = sum(num_patients_target_cycle1)    / sum(num_patients_cycle1),
      prob_patients_underdose_cycle1 = sum(num_patients_underdose_cycle1) / sum(num_patients_cycle1)
    ) |>
    filter(scenario == cur_scenario)
  
  res_long <- res |> 
    pivot_longer(
      cols = starts_with("prob_patients"), 
      names_transform = function(name) {
        name |>
          str_replace_all("prob_patients_", "") |> 
          str_replace_all("_cycle1", "")
      }
    ) |> 
    mutate(name = factor(name)) |>
    mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), ""))
  
  cur_plot <- res_long |>
    ggplot(aes(x = dropout, y = value, fill = name)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    # stat_slab(
    #   position = position_dodgejust(width = 0.8), 
    #   width = 0.8, 
    # ) +
    #geom_boxplot( alpha = 0.5) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cycle1_patients) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Interval') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) +
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cycle1_patients <- c(p_cycle1_patients, list(cur_plot))
}
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
Code
plot_cycle1_patients <- ggarrange( plotlist = p_cycle1_patients, common.legend = T, ncol = 3)
plot_cycle1_patients_ann <- plot_cycle1_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients in cycle 1",
      color = "black", face = "bold", size = 14
    )
  )

ggsave(file.path(path.export, "patients_cycle1_frequencies.png"), plot = plot_cycle1_patients_ann , width=20*2.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "patients_cycle1_frequencies.pdf"), plot = plot_cycle1_patients_ann , width=20*2.5, height=10*1.2, units="cm")

plot_cycle1_patients_ann

Patient allocation, Cumulative

Code
p_cumulative_patients = list()
for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  res <- outcome_fig_noninformative |>
    select(
      scenario, model, dropout, 
      num_patients_cumulative, 
      num_patients_overdose_cumulative,
      num_patients_target_cumulative,
      num_patients_underdose_cumulative
    ) |>
    group_by(scenario, model, dropout) |>
    summarize(
      prob_patients_overdose_cumulative  = sum(num_patients_overdose_cumulative)  / sum(num_patients_cumulative),
      prob_patients_target_cumulative    = sum(num_patients_target_cumulative)    / sum(num_patients_cumulative),
      prob_patients_underdose_cumulative = sum(num_patients_underdose_cumulative) / sum(num_patients_cumulative)
    ) |>
    filter(scenario == cur_scenario)
  
  res_long <- res |> 
    pivot_longer(
      cols = starts_with("prob_patients"), 
      names_transform = function(name) {
        name |>
          str_replace_all("prob_patients_", "") |> 
          str_replace_all("_cumulative", "")
      }
    ) |>     
    mutate(name = factor(name)) |>
    mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), ""))
  
  cur_plot <- res_long |>
    ggplot(aes(x = dropout, y = value, fill = name)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    # stat_slab(
    #   position = position_dodgejust(width = 0.8), 
    #   width = 0.8, 
    # ) +
    # geom_boxplot( alpha = 0.5) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cumulative_patients) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Interval') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) +
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cumulative_patients <- c(p_cumulative_patients, list(cur_plot))
}
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
Code
plot_cumulative_patients <- ggarrange( plotlist = p_cumulative_patients, common.legend = T, ncol = 3)
plot_cumulative_patients_ann <- plot_cumulative_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients over 3 cycles (cumulative)",
      color = "black", face = "bold", size = 14
    )
  )


ggsave(file.path(path.export, "patients_cumulative_frequencies.png"), plot = plot_cumulative_patients_ann , width=20*2.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "patients_cumulative_frequencies.pdf"), plot = plot_cumulative_patients_ann , width=20*2.5, height=10*1.2, units="cm")

ggsave(file.path(path.export, "patient_allocation_main.png"), plot = p_cumulative_patients[[1]] + ggtitle("Probability of dosing patients over 3 cycles,\n(cumulative) constant toxicity"), width=15, height=12, units="cm")

ggsave(file.path(path.export, "patient_allocation_main.pdf"), plot = p_cumulative_patients[[1]] + ggtitle("Probability of dosing patients over 3 cycles,\n(cumulative) constant toxicity"), width=15, height=12, units="cm")



plot_cumulative_patients_ann

Joint figure

Code
plotlist_both <- c(
    p_cycle1_patients |> map(\(x){x + xlab("")}), 
    p_cumulative_patients |> map(\(x){x + ggtitle("")})
  )

plotlist_both[[1]] <- plotlist_both[[1]] + ylab("Relative frequencies, cycle-1")
plotlist_both[[4]] <- plotlist_both[[4]] + ylab("Relative frequencies, cumulative")
plot_both_patients <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 3, nrow = 2
)
plot_both_patients_ann <- plot_both_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients",
      color = "black", face = "bold", size = 14
    )
  )

ggsave(file.path(path.export, "patient_frequencies.pdf"), plot = plot_both_patients_ann , width=20*2.5, height=10*2, units="cm")
ggsave(file.path(path.export, "patient_frequencies.png"), plot = plot_both_patients_ann , width=20*2.5, height=10*2, units="cm")

plot_both_patients_ann

Trial length

Code
p_trial_length_days = list()

res <- outcome_fig_noninformative |>
  select(
    scenario, model, dropout, 
    start_to_last_patient_cens_event_dt
  ) |>
  mutate(length_years = time_length(start_to_last_patient_cens_event_dt, "years"))

for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- res |> filter(scenario == cur_scenario) |>
    ggplot(aes(x = dropout, y = length_years)) + 
    ggtitle(paste(cur_scenario, "toxicity")) + 
    # stat_slab(
    #   position = position_dodgejust(width = 0.8), 
    #   width = 0.8, 
    # ) +
    geom_boxplot( alpha = 0.5) +
    ylab(ifelse(length(p_trial_length_days) == 0, "Years", "")) +
    scale_y_continuous(breaks=c(0, 2, 4, 6, 8), limits=c(0, 9)) + 
    xlab("Dropout over 3 cycles") + 
    # scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
    facet_grid(. ~ model, scales = "free", space = "free_x")+
    labs(fill='Interval') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1))
  
  cur_data_summary <- res |> 
    filter(scenario == cur_scenario) |>
    group_by(dropout, model) |> 
    summarize(length_years = rvar(length_years), .groups = "keep") |>
    mutate(
      length_years_mean = mean(length_years),
      length_years_mean_mcse = mcse_mean(length_years)
    )
  
  cat(paste0("\n### ", cur_scenario, "\n\n"))

  if (interactive()) {
    print(cur_data_summary |> kable())
  } else {
    cat(sep = "\n", knitr::knit_child(quiet = TRUE, text = c(
      "```{r}",
      "#| echo: false",
      "cur_data_summary |> kable(digits = 1)",
      "```"
    )))
  }
  
  p_trial_length_days <- c(p_trial_length_days, list(cur_plot))
}

constant

dropout model length_years length_years_mean length_years_mean_mcse
0% B1 1.7 ± 0.25 1.7 0
0% B3 2.2 ± 0.74 2.2 0
0% TCO 1.7 ± 0.26 1.7 0
0% TCU 1.3 ± 0.32 1.3 0
33% B1 1.9 ± 0.27 1.9 0
33% B3 2.8 ± 1.06 2.8 0
33% TCO 1.8 ± 0.31 1.8 0
33% TCU 1.4 ± 0.38 1.4 0
55% B1 2.0 ± 0.30 2.0 0
55% B3 3.3 ± 1.41 3.3 0
55% TCO 1.8 ± 0.33 1.8 0
55% TCU 1.5 ± 0.40 1.5 0

increasing

dropout model length_years length_years_mean length_years_mean_mcse
0% B1 1.8 ± 0.24 1.8 0
0% B3 2.2 ± 0.73 2.2 0
0% TCO 1.7 ± 0.28 1.7 0
0% TCU 1.3 ± 0.34 1.3 0
33% B1 2.0 ± 0.28 2.0 0
33% B3 2.8 ± 1.06 2.8 0
33% TCO 1.8 ± 0.33 1.8 0
33% TCU 1.4 ± 0.39 1.4 0
55% B1 2.1 ± 0.32 2.1 0
55% B3 3.4 ± 1.41 3.4 0
55% TCO 1.9 ± 0.35 1.9 0
55% TCU 1.5 ± 0.42 1.5 0

decreasing

dropout model length_years length_years_mean length_years_mean_mcse
0% B1 1.7 ± 0.22 1.7 0
0% B3 2.2 ± 0.73 2.2 0
0% TCO 1.7 ± 0.26 1.7 0
0% TCU 1.3 ± 0.33 1.3 0
33% B1 1.8 ± 0.28 1.8 0
33% B3 2.7 ± 1.08 2.7 0
33% TCO 1.8 ± 0.31 1.8 0
33% TCU 1.4 ± 0.38 1.4 0
55% B1 1.9 ± 0.31 1.9 0
55% B3 3.0 ± 1.44 3.0 0
55% TCO 1.8 ± 0.32 1.8 0
55% TCU 1.5 ± 0.40 1.5 0
Code
plot_trial_length_days <- ggarrange( plotlist = p_trial_length_days[c(2,3)], common.legend = T, ncol = 2)
plot_trial_length_days_ann <- plot_trial_length_days |>
  annotate_figure(
    top = text_grob(
      "Absolute trial length",
      color = "black", face = "bold", size = 14
    )
  )

trial_length_const <- p_trial_length_days[[1]] + ggtitle("Absolute trial length, constant toxicity") 

ggsave(file.path(path.export, "trial_lengths_all.pdf"), plot = plot_trial_length_days_ann, width=10*2.2, height=14, units="cm")

ggsave(file.path(path.export, "trial_lengths.png"), plot = trial_length_const, width=10, height=14, units="cm")
ggsave(file.path(path.export, "trial_lengths.pdf"), plot = trial_length_const, width=10, height=14, units="cm")

Constant scenario plot

Code
trial_length_const

Increasing / decreasing scenario plot

Code
plot_trial_length_days_ann

MTD dose distribution

Code
p = list()

for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) |>
    ggplot(aes(x = dropout, y = MTD_dose, fill = model)) +
    # geom_boxplot(alpha = 0.5) + 
    scale_y_continuous(trans = 'log10', breaks = sort(unique(outcome_fig_noninformative$MTD_dose))) +
    stat_histinterval(
      position = position_dodgejust(width = 0.8),
      width = 0.8
    ) +
    # geom_hline(yintercept = true_critical_dose[i],  color = "black", size=1) +
    # # geom_hline(yintercept = 5.03,  color = "black", size=1,linetype = "dashed") + 
    ylab("MTD") +xlab("Historical sample size (n_h)")+
    theme(axis.text.x = element_text(size = 9))  +
    ggtitle(paste(cur_scenario, "toxicity"))+
    labs(fill='Model:')
  
  p <- c(p, list(cur_plot))
}
plot_MTDs <- ggarrange(plotlist = p, common.legend = T, ncol = 3) 
Warning: Removed 896 rows containing missing values (`stat_slabinterval()`).
Removed 896 rows containing missing values (`stat_slabinterval()`).
Warning: Removed 1012 rows containing missing values (`stat_slabinterval()`).
Warning: Removed 974 rows containing missing values (`stat_slabinterval()`).
Code
plot_MTDs_ann <- plot_MTDs |> annotate_figure(
  top = text_grob("Distribution of declared MTDs", 
  color = "black", face = "bold", size = 14)
)

plot_MTDs_ann

Informative stopping reasons & MTD allocation, Cycle 1

Code
preprocess_data_MTD_cycle1_info <- function(x) {
  x |> 
    count(model, x_label, stop_reason_cycle1) |>    
    group_by(model, x_label) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

cur_plot_cycle1_MTDs <- outcome_fig_informative |>
  preprocess_data_MTD_cycle1_info() |>
  ggplot(aes(x_label, y = n, fill = stop_reason_cycle1)) + 
  geom_bar(position = "fill", alpha = 0.8, stat = "identity") + 
  ylab("Relative frequencies") +
  xlab("Informative dropout?") + 
  scale_fill_manual(values = dosing_colors, drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Stopping reason') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  


plot_cycle1_MTDs_ann <- cur_plot_cycle1_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: Informative censoring, cycle-1 MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_cycle1_MTDs_ann

Informative stopping reasons & MTD allocation, Cumulative

Code
preprocess_data_MTD_cumulative_info <- function(x) {
  x |> 
    count(model, x_label, stop_reason_cumulative) |>    
    group_by(model, x_label) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

cur_plot_cumulative_MTDs_info <- outcome_fig_informative |>
  preprocess_data_MTD_cumulative_info() |>
  ggplot(aes(x_label, y = n, fill = stop_reason_cumulative)) + 
  geom_bar(position = "fill", alpha = 0.8, stat = "identity") + 
  ylab("Relative frequencies") +
  xlab("Informative dropout?") + 
  scale_fill_manual(values = dosing_colors, drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Stopping reason') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
  geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    ) + 
  theme(legend.justification = "center", legend.position = "top")
  


plot_cumulative_MTDs_info_ann <- cur_plot_cumulative_MTDs_info |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: Informative censoring, cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  ) 



plot_cumulative_MTDs_info_ann

Code
ggsave(file.path(path.export, "MTD_cumulative_frequencies_info.png"), plot = plot_cumulative_MTDs_info_ann , width=20*1.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "MTD_cumulative_frequencies_info.pdf"), plot = plot_cumulative_MTDs_info_ann , width=20*1.5, height=10*1.2, units="cm")

Joint plot

Code
plotlist_both <- list(
    cur_plot_cycle1_MTDs + xlab("") + ylab("Relative frequencies, cycle-1") + guides(fill = guide_legend(nrow = 2)), 
    cur_plot_cumulative_MTDs_info + ggtitle("") + ylab("Relative frequencies, cumulative")
  )

plot_both_patients <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 1, nrow = 2
)
plot_both_patients_ann_info <- plot_both_patients |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cycle-1 and cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_both_patients_ann_info

Code
ggsave(file.path(path.export, "MTD_frequencies_info.pdf"), plot = plot_both_patients_ann_info , width=20, height=20, units="cm")

Informative patient allocation, Cycle-1

Code
res <- outcome_fig_informative |>
  select(
    model, x_label,
    num_patients_cycle1, 
    num_patients_overdose_cycle1,
    num_patients_target_cycle1,
    num_patients_underdose_cycle1
  ) |>
  group_by(model, x_label) |>
  summarize(
    prob_patients_overdose_cycle1  = sum(num_patients_overdose_cycle1)  / sum(num_patients_cycle1),
    prob_patients_target_cycle1    = sum(num_patients_target_cycle1)    / sum(num_patients_cycle1),
    prob_patients_underdose_cycle1 = sum(num_patients_underdose_cycle1) / sum(num_patients_cycle1)
  ) 
`summarise()` has grouped output by 'model'. You can override using the
`.groups` argument.
Code
res_long <- res |> 
  pivot_longer(
    cols = starts_with("prob_patients"), 
    names_transform = function(name) {
      name |>
        str_replace_all("prob_patients_", "") |> 
        str_replace_all("_cycle1", "")
    }
  ) |> 
  mutate(name = factor(name)) |>
  mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), "")) 

cur_plot_cycle1_patients <- res_long |>
  ggplot(aes(x = x_label, y = value, fill = name)) + 
  # stat_slab(
  #   position = position_dodgejust(width = 0.8), 
  #   width = 0.8, 
  # ) +
  geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
  ylab(ifelse(length(p_cycle1_patients) == 0, "Relative frequencies", "")) +
  xlab("Informative dropout?") + 
  scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Interval') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
  geom_text(
    aes(label = percent),
    position = position_fill(vjust=0.5),
    size = 3
  )

plot_cycle1_patients_ann <- cur_plot_cycle1_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients in cycle 1",
      color = "black", face = "bold", size = 14
    )
  )

plot_cycle1_patients_ann

Informative patient allocation, Cumulative

Code
p_cumulative_patients = list()

res <- outcome_fig_informative |>
  select( 
    model, x_label, 
    num_patients_cumulative, 
    num_patients_overdose_cumulative,
    num_patients_target_cumulative,
    num_patients_underdose_cumulative
  ) |>
  group_by(model, x_label) |>
  summarize(
    prob_patients_overdose_cumulative  = sum(num_patients_overdose_cumulative)  / sum(num_patients_cumulative),
    prob_patients_target_cumulative    = sum(num_patients_target_cumulative)    / sum(num_patients_cumulative),
    prob_patients_underdose_cumulative = sum(num_patients_underdose_cumulative) / sum(num_patients_cumulative)
  ) 
`summarise()` has grouped output by 'model'. You can override using the
`.groups` argument.
Code
res_long <- res |> 
  pivot_longer(
    cols = starts_with("prob_patients"), 
    names_transform = function(name) {
      name |>
        str_replace_all("prob_patients_", "") |> 
        str_replace_all("_cumulative", "")
    }
  ) |>
  mutate(name = factor(name)) |>
  mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), "")) 
  

cur_plot_cumulative_patients <- res_long |>
  ggplot(aes(x = x_label, y = value, fill = name)) + 
  # stat_slab(
  #   position = position_dodgejust(width = 0.8), 
  #   width = 0.8, 
  # ) +
  geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
  ylab(ifelse(length(p_cumulative_patients) == 0, "Relative frequencies", "")) +
  xlab("Informative dropout?") + 
  scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Interval') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
  geom_text(
    aes(label = percent),
    position = position_fill(vjust=0.5),
    size = 3
  ) +   theme(legend.justification = "center", legend.position = "top")

plot_cumulative_patients_ann <- cur_plot_cumulative_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients over 3 cycles (cumulative)",
      color = "black", face = "bold", size = 14
    )
  )

plot_cumulative_patients_ann

Code
ggsave(file.path(path.export, "patient_cumulative_frequencies_info.png"), plot = plot_cumulative_patients_ann , width=20*1.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "patient_cumulative_frequencies_info.pdf"), plot = plot_cumulative_patients_ann , width=20*1.5, height=10*1.2, units="cm")

Joint plot

Code
plotlist_both <- list(
    cur_plot_cycle1_patients + xlab("") + ylab("Relative frequencies, cycle-1"), 
    cur_plot_cumulative_patients + ggtitle("") + ylab("Relative frequencies, cumulative")
  )

plot_both_patients <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 1, nrow = 2
)
plot_both_patients_ann_info <- plot_both_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients",
      color = "black", face = "bold", size = 14
    )
  )

ggsave(file.path(path.export, "patient_frequencies_info.pdf"), plot = plot_both_patients_ann_info , width=20, height=20, units="cm")


plot_both_patients_ann_info

Trial length

Code
plot_trial_length_days_info <- outcome_fig_informative |>
  mutate(length_years = time_length(start_to_last_patient_cens_event_dt, "years")) |>
  ggplot(aes(x = x_label, y = length_years)) + 
  geom_boxplot( alpha = 0.5) +
  ylab(ifelse(length(p_trial_length_days) == 0, "Years", "")) +
  xlab("Dropout over 3 cycles") + 
    # scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  #labs(fill='Interval') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5))
  
  # ggplot(aes(x_label, y = n, fill = stop_reason_cumulative)) + 
  # geom_bar(position = "fill", alpha = 0.8, stat = "identity") + 
  # ylab("Relative frequencies") +
  # xlab("Informative dropout?") + 
  # scale_fill_manual(values = dosing_colors, drop = FALSE) +
  # facet_grid(. ~ model, scales = "free", space = "free_x")+


plot_trial_length_days_info_ann <- plot_trial_length_days_info |>
  annotate_figure(
    top = text_grob(
      "Absolute trial lengths: Informative censoring",
      color = "black", face = "bold", size = 14
    )
  )


ggsave(file.path(path.export, "trial_lengths_info.png"), plot = plot_trial_length_days_info_ann , width=20, height=14, units="cm")

ggsave(file.path(path.export, "trial_lengths_info.pdf"), plot = plot_trial_length_days_info_ann , width=20, height=14, units="cm")
Code
plot_trial_length_days_info_ann